home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
TPUG - Toronto PET Users Group
/
TPUG Users Group CD
/
TPUG Users Group CD.iso
/
AMIGA
/
AMICUS
/
AMICUS15.ADF
/
AmigaBasicProgs
/
MigaSol
(
.txt
)
< prev
next >
Wrap
AmigaBASIC Source Code
|
1988-04-20
|
16KB
|
785 lines
CLEAR, 40960
DEFINT a-z
OPTION BASE 1
DIM deck(52),upcp(7,12),downcp(7,6),cpndx(7,2),ap(4,12) 'card pile arrays
DIM suit(21,4), cardval(21,13), card(99,52) 'card graphics arrays
DIM topdeck(2), temp(2,2), drawdeck(24), playdeck(24)
GOTO Begin
'MigaSol version 1.0
'Copyright 1986, Jon Scarpelli. All rights reserved.
'The author retains all rights to this software and
'hereby grants license for the free dissemination
'of this software product for non-commercial use only
'under the sole condition that this notice not be
'removed. The author reserves the right to revoke this
'license at any time.
'Now that that's done, this software is distributed as
'Shareware. If you find yourself using this software
'and would like to encourage both the Shareware concept
'and further development of this program, please send
'a contribution ($10 would be nice) to the author:
' Jon Scarpelli
' 3209 Lindenwood
' Dearborn, MI 48120
'Planned enhancements include music, rules to reduce but
'not eliminate cheating, score keeping, and an UNDO
'function. Your comments and suggestions will be
'appreciated. ENJOY THIS!
Begin:
GOSUB GetGraphics
GOSUB StartGame
LOCATE 16,3:PRINT "HELP"
LOCATE 18,3:PRINT "PLAY "
HelpOrPlay:
WHILE MOUSE(0)<>1:WEND
x=MOUSE(3):y=MOUSE(4)
IF x>16 AND x<48 AND y>120 AND y<129 THEN
HelpNeeded=-1
END IF
IF HelpNeeded THEN
GOSUB PlayInstructions
GOTO CheckMouse
ELSE
LOCATE 16,3:PRINT "Have at it! "
LOCATE 18,3:PRINT "REDEAL"
GOTO CheckMouse
END IF
CheckMouse:
WHILE MOUSE(0)<>1:WEND
x=MOUSE(3):y=MOUSE(4)
ProcessSelection:
LOCATE 2,3
PRINT "Wait..."
LOCATE 3,3
PRINT " "
LOCATE 16,3
PRINT " "
IF x>16 AND x<56 AND y>152 AND y<161 THEN
IF click=frompos THEN
Oops=-1:click=newpos
GOTO ShowSelect
ELSE
LOCATE 16,3:PRINT "Too late... "
END IF
ELSEIF x>16 AND x<64 AND y>136 AND y<145 THEN
redeal=-1
GOSUB StartGame
GOTO CheckMouse
ELSE
click=click*-1
END IF
IF click=frompos THEN
fromcardpile=0:fromplaypile=0
tocardpile=0:newpile=0
END IF
GOSUB TestPile
IF UsingCardpile THEN
IF cpndx(pile,up)>0 THEN 'up card available
GOSUB TestUpCard 'was card picked available & get y positions
IF validcard THEN
IF click=frompos THEN
fromx1=x1:fromy1=y1
fromx2=x2:fromy2=y2
fromcard=card:frompile=pile
fromupndx=cpndx(pile,up)
fromdownndx=cpndx(pile,down)
cardstomove=fromupndx-card+1
fromcardpile=-1
ELSE 'click=newpos
tocardpile=-1
newx1=x1:newy1=y1
newx2=x2:newy2=y2
newcard=card:newpile=pile
newupndx=cpndx(newpile,up)
IF fromcardpile THEN
GOSUB UpdateArrays
IF OkToMove THEN
GOSUB MoveCard
END IF
ELSE
GOSUB UsePlayPile
END IF
END IF
ELSE
click=click*-1
END IF
ELSEIF cpndx(pile,down)>0 THEN 'down card available
GOSUB TestDownCard
IF validcard THEN
IF click=frompos THEN 'turn card over
CurrentCard=downcp(pile,1)
PUT (x1,y1),card(1,CurrentCard),PSET
IF cpndx(pile,down)>1 THEN
FOR i=1 TO 5
downcp(pile,i)=downcp(pile,i+1)
NEXT i
END IF
cpndx(pile,up)=1
cpndx(pile,down)=cpndx(pile,down)-1
cpndx(pile,up)=1
upcp(pile,1)=CurrentCard
click=click*-1
END IF
ELSE
click=click*-1
END IF
ELSE 'empty pile
IF click=newpos THEN
newcard=1:newpile=pile
newy1=5:newx1=x1:newupndx=0
IF fromcardpile THEN
GOSUB UpdateArrays
IF OkToMove THEN
GOSUB MoveCard
END IF
ELSE
tocardpile=-1
GOSUB UsePlayPile
END IF
ELSE
LOCATE 16,3
PRINT "Not today... "
click=click*-1
END IF
END IF
ELSEIF ace1pile OR ace2pile OR ace3pile OR ace4pile THEN
IF click=newpos THEN
newx1=580:newcard=1
IF ace1pile THEN
newpile=1:newy1=35
ELSEIF ace2pile THEN
newpile=2:newy1=70
ELSEIF ace3pile THEN
newpile=3:newy1=105
ELSE
newpile=4:newy1=140
END IF
GOSUB UpdateAceArray
IF OkToMove THEN
IF fromplaypile THEN
GOSUB UsePlayPile
ELSE
GOSUB MoveCard
END IF
END IF
END IF
ELSEIF UsingDrawpile THEN
GOSUB UseDrawPile
click=newpos
ELSEIF UsingPlaypile AND cardtoplay>0 THEN
GOSUB UsePlayPile
ELSE
click=click*-1
END IF
ShowSelect:
Oops=0
LOCATE 2,3
PRINT "Select "
LOCATE 3,3
IF click=frompos THEN
PRINT "To... "
ELSE
PRINT "From..."
END IF
GOTO CheckMouse
TestPile:
UsingCardpile=0:pile=0
UsingDrawpile=0:UsingPlaypile=0
ace1pile=0:ace2pile=0
ace3pile=0:ace4pile=0
IF y>4 AND y<161 AND x>131 AND x<549 THEN
IF x>131 AND x<164 THEN
pile=1:UsingCardpile=-1
x1=132:x2=163
ELSEIF x>195 AND x<228 THEN
pile=2:UsingCardpile=-1
x1=196:x2=227
ELSEIF x>259 AND x< 292 THEN
pile=3:UsingCardpile=-1
x1=260:x2=291
ELSEIF x>323 AND x<356 THEN
pile=4:UsingCardpile=-1
x1=324:x2=355
ELSEIF x>387 AND x<420 THEN
pile=5:UsingCardpile=-1
x1=388:x2=419
ELSEIF x>451 AND x< 484 THEN
pile=6:UsingCardpile=-1
x1=452:x2=483
ELSEIF x>515 AND x<548 THEN
pile=7:UsingCardpile=-1
x1=516:x2=547
ELSE
LOCATE 16,3
PRINT "Which pile? "
END IF
ELSEIF x>19 AND x<52 AND y>39 AND y<64 THEN
UsingPlaypile=-1
x1=20:y1=40:x2=51:y2=63
ELSEIF x>19 AND x<52 AND y>79 AND y<104 THEN
UsingDrawpile=-1
ELSEIF x>579 AND x<612 AND click=newpos THEN
x1=580:x2=611
IF y>34 AND y<59 THEN
ace1pile=-1 '1st ace pile
y1=35:y2=58
ELSEIF y>69 AND y<94 THEN
ace2pile=-1 '2nd ace pile, etc.
y1=70:y2=93
ELSEIF y>104 AND y<129 THEN
ace3pile=-1
y1=105:y2=128
ELSEIF y>139 AND y<164 THEN
ace4pile=-1
y1=140:y2=163
ELSE
LOCATE 16,3
PRINT "How's that? "
END IF
ELSE
LOCATE 16,3
PRINT "Whuh..?? "
END IF
RETURN
TestUpCard:
card=0:validcard=0
IF y>4 AND y<161 THEN card=INT((y-5)/12)+1
IF card<=cpndx(pile,up) THEN 'pointing to top half
validcard=-1 'of any up card
ELSEIF card-1=cpndx(pile,up) THEN 'pointing to bottom
card=card-1 'half of last up card
validcard=-1
ELSE
LOCATE 16,3:PRINT "Which card? "
END IF
'Get y1 and y2 position
IF validcard THEN 'card <= cpndx
y1=5+(card-1)*12
y2=5+(cpndx(pile,up)+1)*12
END IF
RETURN
TestDownCard:
card=0:validcard=0
IF y>4 AND y<161 THEN card=INT((y-5)/12)+1
IF card=1 OR card=2 THEN
card=1
y1=5
validcard=-1
ELSE
LOCATE 16,3:PRINT "Come again? "
END IF
RETURN
UpdateArrays:
OkToMove=0
IF frompile<>newpile THEN
GOSUB FromPileRedraw
j=1
IF newupndx>0 THEN 'cards already showing
newy1=newy1+12 'offset so as not to cover
END IF
FOR i=fromcard TO fromcard+cardstomove-1
upcp(newpile,newupndx+j)=upcp(frompile,i)
upcp(frompile,i)=0
j=j+1
NEXT i
cpndx(frompile,up)=fromupndx-cardstomove
cpndx(newpile,up)=newupndx+cardstomove
OkToMove=-1
ELSE
LOCATE 16,3
PRINT "Nope... "
END IF
RETURN
UpdateAceArray:
OkToMove=0
IF fromcardpile THEN
CurrentCard=upcp(frompile,fromcard)
ELSE
CurrentCard=playdeck(cardtoplay)
END IF
IF ap(newpile,1)>0 THEN 'not 1st card on pile
IF CurrentCard=ap(newpile,1)+1 THEN 'consequtive cards
IF fromcardpile THEN
GOSUB FromPileRedraw
upcp(frompile,fromcard)=0
cpndx(frompile,up)=fromupndx-1
END IF
newx1=580:newcard=1
FOR i=1 TO 11
ap(newpile,i+1)=ap(newpile,i)
NEXT i
ap(newpile,1)=CurrentCard
OkToMove=-1
ELSE
LOCATE 16,3
PRINT "Can't do that"
END IF
ELSEIF CurrentCard=1 OR CurrentCard=14 OR CurrentCard=27 OR CurrentCard=40 THEN
IF fromcardpile THEN
GOSUB FromPileRedraw
upcp(frompile,fromcard)=0
cpndx(frompile,up)=fromupndx-1
END IF
newx1=580:newcard=1
ap(newpile,1)=CurrentCard
OkToMove=-1
ELSE
LOCATE 16,3
PRINT "Can't do that"
END IF
RETURN
FromPileRedraw:
DrawEmptyPile=0:DrawCardBack=0
IF fromcard=1 THEN '1st card moving
IF fromdownndx>0 THEN 'down cards available
DrawCardBack=-1
ELSE
DrawEmptyPile=-1
END IF
ELSE
CardToRedraw=upcp(frompile,fromcard-1)
END IF
RETURN
MoveCard:
ERASE temp
arraysize=3+INT((16+fromx2-fromx1)/16)*(1+fromy2-fromy1)*2
DIM temp(arraysize,2)
GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1) ' cards
GET (fromx1-32,fromy1)-(fromx2-32,fromy2),temp(1,2) 'clear background
PUT (fromx1,fromy1),temp(1,2),PSET 'clear fromcards
'put bottom half of card left or empty pile or back of down card
IF DrawEmptyPile THEN
LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),1,b
DrawEmptyPile=0
ELSEIF DrawCardBack THEN
PATTERN ,topdeck
COLOR 3,2
LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),,bf
DrawCardBack=0
ELSE
PUT (fromx1,fromy1-12),card(1,CardToRedraw),PSET
END IF
PUT (newx1,newy1),temp(1,1),PSET
RETURN
UseDrawPile:
IF click = frompos THEN
IF cardsdealt < cardstodeal THEN
IF cardsdealt < cardstodeal-2 THEN
FOR i=1 TO 3
playdeck(cardtoplay+i)=drawdeck(cardsdealt+i)
NEXT i
cardtoplay=cardtoplay+3
cardsdealt=cardsdealt+3
ELSEIF cardsdealt=cardstodeal-2 THEN
playdeck(cardtoplay+1)=drawdeck(cardsdealt+1)
playdeck(cardtoplay+2)=drawdeck(cardsdealt+2)
cardtoplay=cardtoplay+2
cardsdealt=cardsdealt+2
ELSEIF cardsdealt=cardstodeal-1 THEN
playdeck(cardtoplay+1)=drawdeck(cardsdealt+1)
cardtoplay=cardtoplay+1
cardsdealt=cardsdealt+1
END IF
newx1=20:newy1=40 'playpile coords
CurrentCard=playdeck(cardtoplay) 'get current card to play
PUT (newx1,newy1),card(1,CurrentCard),PSET 'show current card
IF cardsdealt = cardstodeal THEN 'draw empty draw pile
ERASE temp
DIM temp(99,2)
GET (60,162)-(91,185),temp(1,2) 'get empty background
PUT (20,80),temp(1,2),PSET 'clear draw deck
LINE (20,80)-(51,103),1,b 'draw empty pile
END IF
ELSE 'empty draw pile
FOR i=1 TO cardstodeal-cardsplayed 'move play pile to draw pile
drawdeck(i) = playdeck(i)
NEXT i
cardstodeal = cardstodeal-cardsplayed
cardsplayed=0:cardtoplay=0:cardsdealt=0
IF cardstodeal>0 THEN
ERASE temp
DIM temp( 99,2)
GET (60,162)-(91,185),temp(1,2) 'get empty background
PUT (20,40),temp(1,2),PSET 'clear play deck
LINE (20,40)-(51,63),1,b 'draw empty pile
PATTERN ,topdeck
COLOR 3,2
LINE (20,80)-(51,103),,bf
END IF
END IF
END IF
RETURN
UsePlayPile:
IF cardtoplay > 0 THEN
IF click = frompos THEN
fromx1=x1:fromx2=x2
fromy1=y1:fromy2=y2
validcard=-1:fromplaypile=-1
fromcardpile=0
ELSE 'click=newpos
CurrentCard=playdeck(cardtoplay)
cardsplayed=cardsplayed+1
cardtoplay=cardtoplay-1
IF cardtoplay=0 THEN
DrawEmptyPile=-1
ELSE
CardToRedraw=playdeck(cardtoplay)
END IF
IF tocardpile THEN
IF newupndx > 0 THEN
newy1=newy1+12
END IF
upcp(newpile,newupndx+1)=CurrentCard
cpndx(newpile,up)=newupndx+1
END IF
ERASE temp
DIM temp(99,2)
GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1)
PUT (newx1,newy1),temp(1,1),PSET
IF NOT DrawEmptyPile THEN
PUT (fromx1,fromy1),card(1,CardToRedraw),PSET
ELSE
GET (60,162)-(91,185),temp(1,2) 'get empty background
PUT (fromx1,fromy1),temp(1,2),PSET 'clear play deck
LINE (fromx1,fromy1)-(fromx2,fromy2),1,b
DrawEmptyPile=0
END IF
OkToMove=-1
END IF
END IF
RETURN
StartGame:
up=1:down=2
frompos=-1:newpos=1:click=newpos:redeal=0
cardstodeal=24:cardsdealt=0:cardtoplay=0
cardsplayed=0
COLOR 1,0
InitArrays:
FOR card=1 TO 52
deck(card)=card
NEXT card
FOR pile=1 TO 7
cpndx(pile,up)=1
cpndx(pile,down)=pile-1
NEXT pile
FOR pile=1 TO 4
FOR card=1 TO 12
ap(pile,card)=0
NEXT card
NEXT pile
FOR card=1 TO 24
playdeck(card)=0
drawdeck(card)=0
NEXT card
FOR pile=1 TO 7
FOR card=1 TO 12
upcp(pile,card)=0
NEXT card
NEXT pile
FOR pile=1 TO 7
FOR card=1 TO 6
downcp(pile,card)=0
NEXT card
NEXT pile
RANDOMIZE TIMER
played=1
Gencards:
FOR i=1 TO 52
x=INT(RND*52+1)
SWAP deck(i),deck(x)
NEXT i
DealCards:
played=0
FOR card=1 TO 7
FOR pile = card TO 7
played=played+1
IF card=1 THEN
upcp(pile,card)=deck(played)
ELSE
downcp(pile,card-1)=deck(played)
END IF
NEXT pile
NEXT card
BuildDrawDeck:
FOR i=29 TO 52
j=i-28
drawdeck(j)=deck(i)
NEXT i
TurnPiles:
CLS
COLOR 1,0
FOR pile=1 TO 7 ' card piles
CurrentCard=upcp(pile,1)
x=132+((pile-1)*64)
y=5
PUT (x,y),card(1,CurrentCard),PSET
NEXT pile
FOR pile=1 TO 4 ' empty ace piles
x=580
y=35*pile
LINE (x,y)-(x+31,y+23),1,b
NEXT pile
' create empty play pile and draw pile
x=20
y=40
LINE (x,y)-(x+31,y+23),1,b
x=20
y=80
PATTERN ,topdeck
COLOR 3,2
LINE (x,y)-(x+31,y+23),,bf
x=1:y=1
LOCATE 18,3
PRINT "REDEAL"
LOCATE 20,3
PRINT "Oops!"
LOCATE 2,3
PRINT "Select "
LOCATE 3,3
PRINT "From..."
RETURN
GetGraphics:
'load 1st 3 words of each array
FOR i=1 TO 4
suit (1,i)=16
suit (2,i)=9
suit (3,i)=2
NEXT i
FOR i=1 TO 13
cardval (1,i)=16
cardval (2,i)=9
cardval (3,i)=2
NEXT i
FOR i=1 TO 52
card (1,i)=32
card (2,i)=24
card (3,i)=2
NEXT i
FOR j=1 TO 4
FOR i=4 TO 12
READ suit(i,j)
NEXT i
NEXT j
FOR j=13 TO 1 STEP -1
FOR i=4 TO 12
READ cardval(i,j)
NEXT i
NEXT j
READ topdeck(1):READ topdeck(2)
k=1
PRINT "Please wait while I print a new deck for you..."
FOR i=1 TO 4
FOR j=1 TO 13
LINE (16,59)-(47,82),1,bf
PUT (16,60),cardval(1,j)
PUT (32,60),suit(1,i)
IF i=1 OR i=3 THEN suitcolor=2 :ELSE suitcolor=3
PAINT (40,64),suitcolor,1
IF j <> 10 AND j <> 13 THEN PAINT (24,60),suitcolor,1
IF j=10 THEN PAINT (24,60),suitcolor,1: PAINT (18,60),suitcolor,1
IF j=13 THEN PAINT (20,60),suitcolor,1
GET (16,59)-(47,82),card(1,k)
k=k+1
NEXT j
NEXT i
RETURN
PlayInstructions:
LOCATE 5,38:PRINT "CARD PILES"
LOCATE 6,9:PRINT "PLAY"
LOCATE 6,67:PRINT "ACES"
LOCATE 11,9:PRINT "DRAW"
LOCATE 16,3:PRINT " "
LOCATE 18,3:PRINT "PLAY"
COLOR 1,0
LOCATE 7,15
PRINT "1 Cards are moved (3 at a time) from the draw pile"
LOCATE 8,15
PRINT " to the play pile by clicking once on the draw pile."
LOCATE 9,15
PRINT "2 A checkered design indicates that a card is face"
LOCATE 10,15
PRINT " down on the pile, ready for play. Down cards are"
LOCATE 11,15
PRINT " turned up by clicking once on the down card."
LOCATE 12,15
PRINT "3 Cards are moved from the play pile and card piles to"
LOCATE 13,15
PRINT " the card piles and ace piles by clicking once on the"
LOCATE 14,15
PRINT " card to be moved (Select From) and then clicking once"
LOCATE 15,15
PRINT " on the card position to move to (Select To)."
LOCATE 16,15
PRINT "4 One-click the empty draw pile to recycle the play pile."
LOCATE 17,15
PRINT "5 Watch the Select box. It tells you what action is "
LOCATE 18,15
PRINT " expected. If you click on a card and see no response in"
LOCATE 19,15
PRINT " the Select box, wait one full second, then click on the"
LOCATE 20,15
PRINT " card indicated in the Select box."
LOCATE 21,15
PRINT "6 Oops! will change Select To... to Select From..."
LOCATE 22,15
PRINT "7 This game will allow you to cheat and win. Good luck."
COLOR 3,2
HelpNeeded=0:redeal=-1
RETURN
'club data
DATA &h0180,&h07e0,&h07e0,&h03c0
DATA &h1ff8,&h3ffc,&h3ffc,&h1db8,&h0180
'heart data
DATA &h0e38,&h1f7c,&h1ffc,&h1ffc
DATA &h1ffc,&h0ff8,&h07f0,&h01c0,&h0080
'spade data
DATA &h0180,&h03c0,&h07e0,&h0ff0
DATA &h1ff8,&h1ff8,&h1db8,&h0180,&h0180
'diamond data
DATA &h0380,&h07c0,&h0fe0,&h3ff8
DATA &h7ffc,&h3ff8,&h0fe0,&h07c0,&h0380
'king data
DATA &h1c38,&h0c30,&h0c60,&h0ce0
DATA &h0fc0,&h0c60,&h0c70,&h0c30,&h1c38
'queen data
DATA &h07c0,&h1c70,&h3838,&h3838
DATA &h3838,&h39b8,&h39b8,&h1cfc,&h07ce
'jack data
DATA &h07f8,&h00e0,&h00e0,&h00e0
DATA &h00e0,&h00e0,&h38e0,&h38e0,&h1fc0
'10 data
DATA &h31fc,&h738e,&h7306,&h3306
DATA &h3306,&h3306,&h3306,&h338e,&h79fc
'9 data
DATA &h07f0,&h0e38,&h0e38,&h0e38
DATA &h07f8,&h0038,&h0e38,&h0770,&h03e0
'8 data
DATA &h07f0,&h1e3c,&h1c1c,&h1e3c
DATA &h07f0,&h1e3c,&h1c1c,&h1e3c,&h07f0
'7 data
DATA &h1ffc,&h1c1c,&h0038,&h0070
DATA &h00e0,&h01c0,&h0380,&h0380,&h0380
'6 data
DATA &h07e0,&h0e00,&h1c00,&h1c00
DATA &h1ff0,&h1c38,&h1c38,&h0e38,&h07f0
'5 data
DATA &h1ff0,&h1c00,&h1c00,&h1ff0
DATA &h0038,&h001c,&h1c1c,&h0e38,&h07f0
'4 data
DATA &h00f8,&h01f8,&h03b8,&h0738
DATA &h0e38,&h1c38,&h1ffc,&h0038,&h0038
'3 data
DATA &h1ffc,&h001c,&h0038,&h03f0
DATA &h0038,&h001c,&h301c,&h1838,&h0ff0
'2 data
DATA &h0ff8,&h1e1c,&h1c1c,&h003c
DATA &h07f8,&h1f00,&h1c00,&h1c00,&h1ff8
'ace data
DATA &h01c0,&h03e0,&h0770,&h0e38
DATA &h1c1c,&h1ffc,&h1c1c,&h1c1c,&h1c1c
'topdeck data
DATA &hf0f0,&h0f0f